#!/bin/sh
#|
if [ "$PLTHOME" = "" ]; then
  exec racket -um "$0" "$@"
else
  exec ${PLTHOME}/bin/racket -um $0 "$@"
fi
|#

#lang at-exp racket/base
(require racket/pretty)

(provide main)
(define (main [arg #f] [filename #f])
  (if (equal? arg "kernstruct")
      (gen-kernstruct filename)
      (print-header)))

(require scribble/text)

#|

Initial symbols are struct types. A non-initial symbol is a struct
type without fields or subtypes. Square brackets are struct fields and
propeties (the latter in curly braces), strings are contracts/comments.

|#

(define info '

(exn [exn_field_check
      (message "immutable string" "error message")
      (continuation-marks "mark set"
                          "value returned by \\scmfirst{current-continuation-marks} immediately before the exception is raised")] 
     -
     (fail [] "exceptions that represent errors"
           (contract [] "inappropriate run-time use of a function or syntactic form"
                     (arity []
                            "application with the wrong number of arguments")
                     (divide-by-zero [] "divide by zero")
                     (non-fixnum-result [] "arithmetic produced a non-fixnum result")
                     (continuation [] "attempt to cross a continuation barrier")
                     (variable [variable_field_check
                                (id "symbol" "the variable's identifier")]
                               "not-yet-defined global or module variable"))
           (#:only-kernstruct
            syntax [syntax_field_check
                    (exprs "immutable list of syntax objects" "illegal expression(s)")
                    {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_syntax_locations, "extract_syntax_locations", 0, -1)|}]
                   "syntax error, but not a \\scmfirst{read} error"
                   (unbound []
                            "unbound module variable")
                   (missing-module [module_path_field_check_3
                                    (path "module path" "module path")
                                    {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_3, "extract_module_path_3", 0, -1)|}]
                                   "error resolving a module path"))
           (read [read_field_check
                  (srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error")
                  {exn:source scheme_source_property  |scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)|}]
                 "\\rawscm{read} parsing error"
                 (eof [] "unexpected end-of-file")
                 (non-char [] "unexpected non-character"))
           (filesystem [] "error manipulating a filesystem object"
                       (exists [] "attempt to create a file that exists already")
                       (version [] "version mismatch loading an extension")
                       (errno [errno_field_check
                               (errno "pair of symbol and number" "system error code")]
                              "error with system error code")
                       (#:only-kernstruct
                        missing-module [module_path_field_check_2
                                        (path "module path" "module path")
                                        {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_2, "extract_module_path_2", 0, -1)|}]
                                       "error resolving a module path"))
           (network [] "TCP and UDP errors"
                    (errno [errno_field_check
                            (errno "pair of symbol and number" "system error code")]
                            "error with system error code"))
           (out-of-memory [] "out of memory")
           (unsupported [] "unsupported feature")
           (user [] "for end users"))

     (break [break_field_check
             (continuation "escape continuation" "resumes from the break")]
            "asynchronous break signal"
            (hang-up []
                     "terminal disconnect")
            (terminate []
                       "termination request")))

)

#|
Not an exception in the above sense:
     (special-comment [width "non-negative exact integer" "width of the special comment in port positions"]
        "raised by a custom input port's special-reading procedure")
|#

(define l info)

(define-struct ex (define string base doc args props guard parent parent-def
                   numtotal depth mark only-kernstruct?))
(define-struct fld (name type doc))
(define-struct prop (scheme-name c-name value))

(define max-exn-args 0)

(define (make-an-ex sym parent parent-def parent-name totalargs args props
                    guard doc depth mark only-kernstruct?)
  (let* ([s (symbol->string sym)]
         [name (string-append parent-name
                              (if (string=? "" parent-name) "" ":")
                              s)]
         [count (+ totalargs (length args))])
    (when (and (> count max-exn-args)
               (not only-kernstruct?))
      (set! max-exn-args count))
    (make-ex (string-append "MZ"
                            (list->string
                             (let loop ([l (string->list name)])
                               (cond
                                [(null? l) '()]
                                [(or (char=? (car l) #\:)
                                     (char=? (car l) #\/)
                                     (char=? (car l) #\-))
                                 (cons #\_ (loop (cdr l)))]
                                [else
                                 (cons (char-upcase (car l))
                                       (loop (cdr l)))]))))
             name
             sym
             doc
             args
             props
             guard
             parent
             parent-def
             count
             depth
             mark
             only-kernstruct?)))

(define (make-arg-list args)
  (cond
   [(null? args) '()]
   [(string? (cadar args))
    (cons (apply make-fld (car args))
          (make-arg-list (cdr args)))]
   [else
    (make-arg-list (cdr args))]))

(define (make-prop-list args)
  (cond
   [(null? args) '()]
   [(symbol? (cadar args))
    (cons (apply make-prop (car args))
          (make-prop-list (cdr args)))]
   [else
    (make-prop-list (cdr args))]))

(define (make-struct-list v parent parent-def parent-name totalargs depth only-kernstruct?)
  (cond
   [(null? v) '()]
   [else
    (let*-values ([(v only-kernstruct?)
                   (if (eq? '#:only-kernstruct (car v))
                       (values (cdr v) #t)
                       (values v only-kernstruct?))]
                  [(s mark)
                   (let* ([s (symbol->string (car v))]
                          [c (string-ref s 0)])
                     (if (or (char=? #\* c)
                             (char=? #\+ c))
                         (values (string->symbol (substring s 1 (string-length s))) c)
                        (values (car v) #f)))]
                  [(e) (make-an-ex s parent parent-def parent-name totalargs
                                   (if (null? (cadr v))
                                       null
                                       (make-arg-list (cdadr v)))
                                   (if (null? (cadr v))
                                       null
                                       (make-prop-list (cdadr v)))
                                   (if (null? (cadr v))
                                       #f
                                       (caadr v))
                                   (caddr v) depth mark
                                   only-kernstruct?)])
      (cons e
       (apply append
              (map
               (lambda (v)
                 (make-struct-list v
                                   e
                                   (ex-define e)
                                   (ex-string e)
                                   (ex-numtotal e)
                                   (add1 depth)
                                   only-kernstruct?))
               (cdddr v)))))]))

(set! l (make-struct-list l #f #f "" 0 0 #f))


(define (gen-kernstruct filename)
  (define preamble '(module kernstruct '#%kernel
                      (#%require (for-syntax '#%kernel))
                      (#%require "define.rkt")
                      (#%require (for-syntax "struct-info.rkt"))
                      
                      (#%provide (all-defined))

                      (define-values-for-syntax
                        (struct:struct-field-info
                         make-struct-field-info
                         struct-field-info-rec?
                         struct-field-info-ref
                         struct-field-info-set!)
                        (make-struct-type 'struct-field-info struct:struct-info
                                          1 0 #f
                                          (list (cons prop:struct-field-info
                                                      (lambda (rec)
                                                        (struct-field-info-ref rec 0))))))


                      (define-values-for-syntax (make-self-ctr-struct-info)
                        (letrec-values ([(struct: make- ? ref set!)
                                         (make-struct-type 'self-ctor-struct-info struct:struct-field-info
                                                           1 0 #f
                                                           (list (cons prop:procedure
                                                                       (lambda (v stx)
                                                                         (let-values ([(id) ((ref v 0))])
                                                                           (if (symbol? (syntax-e stx))
                                                                               id
                                                                               (datum->syntax stx
                                                                                              (cons id (cdr (syntax-e stx)))
                                                                                              stx
                                                                                              stx))))))
                                                           (current-inspector) #f '(0))])
                          make-))))
  
  (define (sss . args)
    (string->symbol (apply string-append (map (λ (x) (if (symbol? x) (symbol->string x) x)) args))))
  
  (define (non-parent x)
    (or (equal? #f x) (equal? #t x)))
  
  (define (gen-ds name-string fields num-selector parent)
    (let* ([name (sss name-string)]
           [kern-name (sss "kernel:" name)]
           [sn (sss "struct:" name)]
           [mn (sss "make-" name)]
           [pn (sss name "?")]
           [fds `(list ,@(map (λ (x) `(quote-syntax ,x)) fields))]
           [fdsset! `'(,@(map (λ (x) #f) fields))]
           [prnt (if (non-parent parent) #t `(quote-syntax ,parent))]
           [name-length (string-length (symbol->string name))]
           [field-names (for/list ([fld (take fields num-selector)])
                          ;; add1 for hyphen
                          (string->symbol (substring (symbol->string fld) (add1 name-length))))])
      `(begin
         (#%require (rename '#%kernel ,kern-name ,name))
         (define ,mn ,kern-name)
         (define-syntax ,name (make-self-ctr-struct-info 
                               (λ () (list (quote-syntax ,sn)
                                           (quote-syntax ,mn)
                                           (quote-syntax ,pn)                              
                                           ,fds
                                           ,fdsset! ,prnt))
                               ',field-names
                               (λ () (quote-syntax ,kern-name)))))))
  
  (define (parent-sym x)
    (let ([parent (ex-parent x)])
      (if (non-parent parent)
          parent
          (string->symbol (ex-string parent)))))
  
  (define (fields exn)
    (define (field-name exn fld)
      (sss  (ex-string exn) "-"  (fld-name fld)))
    (if (non-parent exn)
        null
        (append (reverse (map (λ (field) (field-name exn field)) (ex-args exn))) (fields (ex-parent exn)))))

  (define exceptions (map (λ (x) (gen-ds (ex-string x) (fields x) (length (ex-args x)) (parent-sym x))) l))
  (define structs (map (λ (x) (apply gen-ds x))
                       '((arity-at-least (arity-at-least-value) 1 #t)
                         (date (date-time-zone-offset date-dst? date-year-day date-week-day date-year 
                                 date-month date-day date-hour date-minute date-second) 10 #t)
                         (date* (date*-time-zone-name date*-nanosecond
                                 date-time-zone-offset date-dst? date-year-day date-week-day date-year 
                                 date-month date-day date-hour date-minute date-second) 2 date)
                         (srcloc (srcloc-span srcloc-position srcloc-column srcloc-line srcloc-source) 5 #t))))
  
  (with-output-to-file filename #:exists 'replace
    (λ ()
      (printf ";; This file was generated by makeexn\n")
      (printf ";;----------------------------------------------------------------------\n")
      (printf ";; record for static info produced by structs defined in c\n")
      (pretty-write (append preamble exceptions structs)))))

(define (print-header)
  @(compose output list){
    /* This file was generated by makeexn */
    #ifndef _MZEXN_DEFINES
    #define _MZEXN_DEFINES
    enum {
    @(add-newlines (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{  @(ex-define e),}))
      MZEXN_OTHER
    };
    #endif

    #ifdef _MZEXN_TABLE

    #define MZEXN_MAXARGS @max-exn-args

    #ifdef GLOBAL_EXN_ARRAY
    static exn_rec exn_table[] = {
    @(let loop ([ll l])
       (let ([e (car ll)])
         (if (ex-only-kernstruct? e)
             (loop (cdr ll))
             (cons @list{  { @(ex-numtotal e), NULL, NULL, 0, NULL, @;
                             @(if (ex-parent e)
                                  (let loop ([pos 0][ll l])
                                    (cond
                                     [(eq? (car ll) (ex-parent e))
                                      pos]
                                     [(ex-only-kernstruct? (car ll))
                                      (loop pos (cdr ll))]
                                     [else
                                      (loop (add1 pos) (cdr ll))]))
                                  -1) }}
                   (if (null? (cdr ll))
                       '()
                       (cons ",\n" (loop (cdr ll))))))))
    };
    #else
    static exn_rec *exn_table;
    #endif

    #endif

    #ifdef _MZEXN_PRESETUP

    #ifndef GLOBAL_EXN_ARRAY
      exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);
    @(add-newlines
      (for/list ([e l] #:unless (ex-only-kernstruct? e))
        @list{  exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"}))
    #endif

    #endif

    #ifdef _MZEXN_DECL_FIELDS
    @(add-newlines
      (for*/list ([e l]
                  #:unless (ex-only-kernstruct? e)
                  [l (in-value (ex-args e))]
                  #:when (pair? l))
        (define fields
          (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", "))
        @list{  static const char *@(ex-define e)_FIELDS[@(length l)] = @;
                 { @fields };
              }))
    #endif

    #ifdef _MZEXN_DECL_PROPS
    @(add-newlines
      (for*/list ([e l]
                   #:unless (ex-only-kernstruct? e)
                   [l (in-value (ex-props e))]
                   #:when (pair? l))
        (define (acons x y l)
          @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)})
        @list{#  define @(ex-define e)_PROPS @;
              @(let loop ([l l])
                 (if (null? l)
                   "scheme_null"
                   (acons (prop-c-name (car l)) (prop-value (car l))
                          (loop (cdr l)))))}))
    #endif

    #ifdef _MZEXN_SETUP
    @(add-newlines
      (for/list ([e l]
                  #:unless (ex-only-kernstruct? e))
        @list{  SETUP_STRUCT(@(ex-define e), @;
                             @(let ([p (ex-parent-def e)])
                                (if p @list{EXN_PARENT(@p)} 'NULL)), @;
                             "@(ex-string e)", @;
                             @(length (ex-args e)), @;
                             @(if (null? (ex-args e))
                                'NULL
                                @list{@(ex-define e)_FIELDS}), @;
                             @(if (null? (ex-props e))
                                'scheme_null
                                @list{@(ex-define e)_PROPS}), @;
                             @(if (ex-guard e)
                                @list{scheme_make_prim_w_arity(@(ex-guard e), "@(ex-guard e)" , 0, -1)}
                                'NULL))}))
    #endif
    @||})
